home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / feel0_89.lha / Feel / Src / modboot.c < prev    next >
C/C++ Source or Header  |  1993-05-13  |  15KB  |  560 lines
  1. /* ******************************************************************** */
  2. /*  modboot.c        Copyright (C) Codemist and University of Bath 1989 */
  3. /*                                                                      */
  4. /*  Wild thing II                                                       */
  5. /* ******************************************************************** */
  6.  
  7. /*
  8.  * $Id: modboot.c,v 2.1 93/01/17 17:25:21 pab Exp $
  9.  *
  10.  * $Log:    modboot.c,v $
  11.  * Revision 2.1  93/01/17  17:25:21  pab
  12.  * 17 Jan 1993 The next generation...
  13.  * 
  14.  * Revision 1.14  1992/11/26  15:56:44  pab
  15.  * Lost Envs, descrim_depth
  16.  *
  17.  * Revision 1.13  1992/06/09  14:04:24  pab
  18.  * fixed includes
  19.  *
  20.  * Revision 1.12  1992/05/26  11:28:03  pab
  21.  * map option added
  22.  *
  23.  * Revision 1.11  1992/04/27  21:57:29  pab
  24.  * correctied some casts
  25.  *
  26.  * Revision 1.10  1992/04/26  21:02:52  pab
  27.  * Added support for static_vectors, plus call to
  28.  * add_boot_module
  29.  * (Stardent bug gone now !)
  30.  *
  31.  * Revision 1.9  1992/03/13  18:12:02  pab
  32.  * sysV fix: move value vectors into shared space
  33.  * so GC can get to them.
  34.  *
  35.  * Revision 1.8  1992/01/29  13:42:45  pab
  36.  * binding fixes
  37.  *
  38.  * Revision 1.7  1992/01/09  22:28:55  pab
  39.  * Fixed for low tag ints
  40.  *
  41.  * Revision 1.6  1992/01/07  22:15:44  pab
  42.  * ncc compatable, plus backtrace
  43.  *
  44.  * Revision 1.5  1992/01/07  17:12:29  pab
  45.  * Added a cast. No sign of the stardent bug
  46.  *
  47.  * Revision 1.4  1992/01/05  22:48:09  pab
  48.  * Minor bug fixes, plus BSD version
  49.  *
  50.  * Revision 1.3  1991/12/22  15:14:19  pab
  51.  * Xmas revision
  52.  *
  53.  * Revision 1.2  1991/09/11  12:07:25  pab
  54.  * 11/9/91 First Alpha release of modified system
  55.  *
  56.  * Revision 1.1  1991/08/12  16:49:47  pab
  57.  * Initial revision
  58.  *
  59.  * Revision 1.4  1991/06/04  17:17:21  kjp
  60.  * No acceptable change.
  61.  *
  62.  * Revision 1.3  1991/02/13  18:23:36  kjp
  63.  * Pass.
  64.  *
  65.  */
  66.  
  67. #include <stdio.h>
  68. #include <string.h>
  69. #include <ctype.h>
  70.  
  71. #include "funcalls.h"
  72. #include "defs.h"
  73. #include "structs.h"
  74. #include "global.h"
  75.  
  76. #include "allocate.h"
  77. #include "symboot.h"
  78.  
  79. #include "ngenerics.h"
  80. #include "modules.h"
  81.  
  82. #include "table.h"
  83. #include "error.h"
  84.  
  85. #include "modboot.h"
  86. #include "bvf.h"
  87.  
  88. /* Current module information */
  89.  
  90. MODULE*  current_open_module; /* The thing itself */
  91. static int      entries;     /* No of entries it claims to have */
  92. static int      entry_count; /* The no of entries thus far */
  93.  
  94. /* Are we generating .i files... */
  95.  
  96. extern int command_line_interface_flag;
  97. #define CREATE_INTERFACE (command_line_interface_flag)
  98.  
  99. /* Interface generators... */
  100.  
  101. static FILE *i_file;
  102.  
  103. static void open_module_interface(char *name)
  104. {
  105.   char i_name[500];
  106.   
  107.   i_name[0]='\0';
  108.   strcat(i_name,name);
  109.   strcat(i_name,".i");
  110.  
  111.   i_file = fopen(i_name,"w");
  112.  
  113.   fprintf(i_file,"((dependencies)\n (exported-ids ");
  114.   fflush(i_file);
  115.   printf("Open %s - ",name); fflush(stdout);
  116. }
  117.  
  118. static void update_interface(char *name,int index,char *class,int argtype)
  119. {
  120.   fprintf(i_file,"\n   ((name . |%s|) (address |%s| |%s|) (class . %s) (argtype . %d) (position %d))",
  121.       name,stringof(current_open_module->name->SYMBOL.pname),name,class,argtype,index);
  122.   fflush(i_file);
  123. }
  124.  
  125. static void close_module_interface()
  126. {
  127.   printf("closing - "); fflush(stdout);
  128.   fprintf(i_file,"))\n");
  129.   fflush(i_file);
  130.   fclose(i_file);
  131.   printf("closed\n"); fflush(stdout);
  132. }
  133.  
  134. void open_module(LispObject *stacktop, MODULE* mod,LispObject *vals,char* name,int ents)
  135. {
  136.   LispObject Fn_make_module(LispObject *);
  137.  
  138.   LispObject sym_name,lisp_ents;
  139.   if (current_open_module != NULL) {
  140.     fprintf(stderr,"\nINITERROR: tried to open '%s' while in '%s'\n",
  141.                name,current_open_module->name);
  142.     system_lisp_exit(1);
  143.   }
  144.  
  145.   sym_name = get_symbol(stacktop,name);
  146.   lisp_ents = allocate_integer(stacktop,ents);
  147.  
  148.   mod=(MODULE *)EUCALL_2(Fn_make_module,sym_name,lisp_ents);
  149.   /* Set up the fresh module */
  150.   
  151.   /* Set up tracking info */
  152.  
  153.   current_open_module = mod;
  154.   entries = ents;
  155.   entry_count = 0;
  156.   
  157.   /* Interface... */
  158.  
  159.   if (CREATE_INTERFACE) open_module_interface(name);
  160. }
  161.  
  162. LispObject make_module_function(LispObject *stacktop,char* lispname,
  163.                 LispObject (*fun)(LispObject*),int argcode)
  164. {
  165.   LispObject lfunc;
  166.   LispObject symbol,number;
  167.  
  168.   if (entry_count == entries) {
  169.     fprintf(stderr,
  170.         "\nINITERROR: more module functions that declared in '%s'\n",
  171.         stringof(current_open_module->name->SYMBOL.pname));
  172.     exit(1);
  173.   }
  174.  
  175.   symbol = get_symbol(stacktop,lispname); /* May or may not allocate anew */
  176.   STACK_TMP(symbol);
  177.  
  178.   vref((current_open_module->values),entry_count) = 
  179.     allocate_module_function(stacktop,(LispObject)current_open_module,
  180.                  symbol,fun,argcode);
  181.   number=allocate_integer(stacktop,entry_count);
  182.   UNSTACK_TMP(symbol);
  183.   /* GC Safe */
  184.   
  185.   SYM_CACHE_INIT(symbol);
  186.   ADD_BINDING(current_open_module,symbol,number,nil);
  187.  
  188.   current_open_module->exported_names = 
  189.     EUCALL_2(Fn_cons,symbol,current_open_module->exported_names);
  190.  
  191.   if (CREATE_INTERFACE) update_interface(lispname,entry_count,"function",argcode);
  192.   ++entry_count;
  193.  
  194.   return(vref(current_open_module->values,entry_count-1));
  195. }
  196.  
  197. LispObject make_unexported_module_function(LispObject *stacktop,char* lispname,
  198.                        LispObject (*fun)(),int argcode)
  199. {
  200.   LispObject lfunc;
  201.   LispObject symbol,number;
  202.  
  203.   if (entry_count == entries) {
  204.     fprintf(stderr,
  205.         "\nINITERROR: more module functions that declared in '%s'\n",
  206.         stringof(current_open_module->name->SYMBOL.pname));
  207.     exit(1);
  208.   }
  209.  
  210.   symbol = get_symbol(stacktop,lispname); /* May or may not allocate anew */
  211.  
  212.   STACK_TMP(symbol);
  213.   vref((current_open_module->values),entry_count) = 
  214.     allocate_module_function(stacktop,(LispObject)current_open_module,
  215.                  symbol,fun,argcode);
  216.   number=allocate_integer(stacktop,entry_count);
  217.   UNSTACK_TMP(symbol);
  218.   
  219.   SYM_CACHE_INIT(symbol);
  220.   ADD_BINDING(current_open_module,symbol,number,nil);
  221.  
  222.  
  223.   /* Symbols can't be GC'd and modules are safe anyway!! */
  224.  
  225.   ++entry_count;
  226.  
  227. /*  fprintf(stderr,"%d OK\n",entry_count); fflush(stderr); */
  228.  
  229.   return(vref((current_open_module->values),entry_count-1));
  230. }
  231.  
  232. LispObject make_module_macro(LispObject *stacktop,char *name,LispObject (*func)(),int args)
  233. {
  234.   LispObject ret;
  235.  
  236.   ret = make_module_function(stacktop,name,func,args);
  237.   lval_typeof(ret) = TYPE_C_MACRO;
  238.  
  239.   return(ret);
  240. }
  241.  
  242. void close_module()
  243. {
  244.   if (current_open_module == NULL) {
  245.     fprintf(stderr,"\nINITERROR: tried to close NULL module\n");
  246.     exit(1);
  247.   }
  248.  
  249.   if (entries != entry_count) {
  250.     fprintf(stderr,
  251.         "\nINITERROR: tried to close '%s' with %d entries, %d needed\n",
  252.         stringof(current_open_module->name->SYMBOL.pname),entry_count,entries);
  253.     exit(1);
  254.   }
  255.  
  256. #ifdef BCI
  257.   add_boot_module((LispObject)current_open_module);
  258. #endif
  259.  
  260.   current_open_module = NULL;
  261.   if (CREATE_INTERFACE) close_module_interface();
  262. }
  263.  
  264.  
  265. LispObject make_unexported_module_special(LispObject *stacktop,char* lispname,LispObject (*fun)())
  266. {
  267.   LispObject number;
  268.   LispObject symbol;
  269.  
  270.   if (entry_count == entries) {
  271.     fprintf(stderr,
  272.         "\nINITERROR: more module functions that declared in '%s'\n",
  273.         stringof(current_open_module->name->SYMBOL.pname));
  274.     exit(1);
  275.   }
  276.  
  277.   symbol = get_symbol(stacktop,lispname); /* May or may not allocate anew */
  278.  
  279.   STACK_TMP(symbol);
  280.   vref((current_open_module->values),entry_count) = allocate_special(stacktop,symbol,fun);
  281.   number=allocate_integer(stacktop,entry_count);
  282.   UNSTACK_TMP(symbol);
  283.   
  284.   SYM_CACHE_INIT(symbol);
  285.   ADD_BINDING(current_open_module,symbol,number,nil);
  286.  
  287.   /* Symbols can't be GC'd and modules are safe anyway!! */
  288.  
  289.   ++entry_count;
  290.  
  291.   return(vref((current_open_module->values),entry_count-1));
  292. }
  293.  
  294. LispObject make_module_entry(LispObject *stacktop,char *name,LispObject value)
  295. {
  296.   LispObject symbol,number;
  297.  
  298.   if (entry_count == entries) {
  299.     fprintf(stderr,
  300.         "\nINITERROR: more module entries that declared in '%s'\n",
  301.         stringof(current_open_module->name->SYMBOL.pname));
  302.     exit(1);
  303.   }
  304.   vref((current_open_module->values),entry_count) = value; 
  305.  
  306.   STACK_TMP(value);
  307.   symbol = get_symbol(stacktop,name); /* May or may not allocate anew */
  308.   STACK_TMP(symbol);
  309.   number = allocate_integer(stacktop,entry_count);
  310.   UNSTACK_TMP(symbol); STACK_TMP(symbol);
  311.   
  312.   SYM_CACHE_INIT(symbol);
  313.   ADD_BINDING(current_open_module,symbol,number,nil);
  314.  
  315.   
  316.   UNSTACK_TMP(symbol);
  317.  
  318.   number =
  319.     EUCALL_2(Fn_cons,symbol,current_open_module->exported_names);
  320.   current_open_module->exported_names = number;
  321.  
  322.   if (CREATE_INTERFACE) update_interface(name,entry_count,"unknown",-1);
  323.   ++entry_count;
  324.  
  325.   UNSTACK_TMP(value);
  326.   return(value);
  327. }
  328.  
  329.  
  330. LispObject make_module_entry_using_symbol(LispObject *stacktop,
  331.                       LispObject symbol,LispObject value)
  332. {
  333.   LispObject number;
  334.   if (entry_count == entries) {
  335.     fprintf(stderr,
  336.         "\nINITERROR: more module entries that declared in '%s'\n",
  337.         stringof(current_open_module->name->SYMBOL.pname));
  338.     exit(1);
  339.   }
  340.   
  341.  
  342.   vref((current_open_module->values),entry_count) = value; 
  343.  
  344.   STACK_TMP(value); STACK_TMP(symbol);
  345.   number = allocate_integer(stacktop,entry_count);
  346.   SYM_CACHE_INIT(symbol);
  347.   ADD_BINDING(current_open_module,symbol,number,nil);
  348.  
  349.   UNSTACK_TMP(symbol); STACK_TMP(symbol);
  350.   current_open_module->exported_names = 
  351.     EUCALL_2(Fn_cons,symbol,current_open_module->exported_names);
  352.   UNSTACK_TMP(symbol);
  353.  
  354.   if (CREATE_INTERFACE) update_interface(stringof(symbol->SYMBOL.pname),entry_count,"unknown",-1);
  355.   ++entry_count;
  356.   UNSTACK_TMP(value);
  357.   return(value);
  358. }
  359.  
  360. LispObject make_module_special(LispObject *stacktop,
  361.                    char* lispname,LispObject (*fun)())
  362. {
  363.   LispObject lfunc;
  364.   LispObject symbol,number;
  365.  
  366.   if (entry_count == entries) {
  367.     fprintf(stderr,
  368.         "\nINITERROR: more module functions that declared in '%s'\n",
  369.         stringof(current_open_module->name->SYMBOL.pname));
  370.     exit(1);
  371.   }
  372.  
  373.   symbol = get_symbol(stacktop,lispname); /* May or may not allocate anew */
  374.   STACK_TMP(symbol);
  375.   vref((current_open_module->values),entry_count) = 
  376.     (LispObject) allocate_special(stacktop,symbol,fun);
  377.   number = allocate_integer(stacktop,entry_count);
  378.   UNSTACK_TMP(symbol);
  379.   STACK_TMP(symbol);
  380.  
  381.   UNSTACK_TMP(symbol);
  382.   /* Symbols can't be GC'd and modules are safe anyway!! */
  383.   SYM_CACHE_INIT(symbol);
  384.   ADD_BINDING(current_open_module,symbol,number,nil);
  385.  
  386.   current_open_module->exported_names = 
  387.     EUCALL_2(Fn_cons,symbol,current_open_module->exported_names);
  388.  
  389.   ++entry_count;
  390.  
  391.   return(vref((current_open_module->values),entry_count-1));
  392. }
  393.  
  394. LispObject make_module_generic(LispObject *stackbase,char *name,int code)
  395. {
  396.   LispObject sym,number,tmp;
  397.   LispObject *stacktop=stackbase+1,*gf=stackbase;
  398.   if (entry_count == entries) {
  399.     fprintf(stderr,
  400.         "\nINITERROR: more module functions that declared in '%s'\n",
  401.         stringof(current_open_module->name->SYMBOL.pname));
  402.     exit(1);
  403.   }
  404.  
  405.   *gf=nil;
  406.   vref(current_open_module->values,entry_count) =
  407.     allocate_instance(stacktop,Generic);
  408.  
  409.   *gf=vref(current_open_module->values,entry_count);
  410.   generic_home(*gf) = (LispObject)current_open_module;
  411.   lval_typeof(*gf)=TYPE_GENERIC;
  412.  
  413.   sym = get_symbol(stacktop,name);
  414.   STACK_TMP(sym);
  415.   tmp = allocate_integer(stacktop,code);
  416.   generic_argtype(*gf)=tmp;
  417.   generic_discrimination_depth(*gf)=allocate_integer(stacktop,0);
  418.   number=allocate_integer(stacktop,entry_count);
  419.   UNSTACK_TMP(sym);
  420.  
  421.   STACK_TMP(number); STACK_TMP(sym);
  422.   generic_name(*gf) = sym;
  423.  
  424.   generic_discriminator(*gf) = nil;
  425.   generic_slow_method_cache(*gf) = nil;
  426.   generic_fast_method_cache(*gf) = nil;
  427.   generic_method_table(*gf) = nil;
  428.   
  429.   generic_method_class(*gf) = Method;
  430.   UNSTACK_TMP(sym); UNSTACK_TMP(number);
  431.   STACK_TMP(sym);
  432.   SYM_CACHE_INIT(sym);
  433.   ADD_BINDING(current_open_module,sym,number,nil);
  434.   UNSTACK_TMP(sym);
  435.   /* Symbols can't be GC'd and modules are safe anyway!! */
  436.  
  437.   current_open_module->exported_names = 
  438.     EUCALL_2(Fn_cons,sym,current_open_module->exported_names);
  439.   
  440.   /** Ought to have code "generic" */
  441.   if (CREATE_INTERFACE) update_interface(name,entry_count,"unknown",code);
  442.   ++entry_count;
  443.  
  444.   return(*gf);
  445. }
  446.  
  447. LispObject make_wrapped_module_generic(LispObject *stacktop,char *name,int code,
  448.                        LispObject (*fun)())
  449. {
  450.   LispObject number;
  451.   LispObject sym,gf,tmp;
  452.   LispObject *stackbase=stacktop;
  453.  
  454.   ARG_0(stackbase) = nil; /*gf*/
  455.   ARG_1(stackbase)=nil; /* number*/
  456.   ARG_2(stackbase)=nil; /*sym*/
  457.  
  458.   stacktop+=3;
  459.   if (entry_count == entries) {
  460.     fprintf(stderr,
  461.         "\nINITERROR: more module functions that declared in '%s'\n",
  462.         stringof(current_open_module->name->SYMBOL.pname));
  463.     exit(1);
  464.   }
  465.  
  466.   sym = get_symbol(stacktop,name);
  467.   ARG_2(stackbase)=sym;
  468.   ARG_0(stackbase) = vref(current_open_module->values,entry_count) =
  469.     allocate_instance(stacktop,Generic);
  470.  
  471.   
  472.   lval_typeof(ARG_0(stackbase))=TYPE_GENERIC;
  473.   generic_home(ARG_0(stackbase)) = (LispObject)current_open_module;
  474.   tmp = allocate_integer(stacktop,code);
  475.   generic_argtype(ARG_0(stackbase)) =tmp;
  476.   generic_discrimination_depth(ARG_0(stackbase)) =allocate_integer(stacktop,0);
  477.   generic_name(ARG_0(stackbase)) = ARG_2(stackbase);
  478.   
  479.   generic_fast_method_cache(ARG_0(stackbase)) = nil;
  480.   generic_slow_method_cache(ARG_0(stackbase)) = nil;
  481.   ARG_1(stackbase)=allocate_integer(stacktop,entry_count);
  482.  
  483.   generic_method_table(ARG_0(stackbase)) = nil;
  484.   generic_method_class(ARG_0(stackbase)) = Method;
  485.  
  486.   generic_discriminator(ARG_0(stackbase)) = nil;
  487.   
  488.   SYM_CACHE_INIT(ARG_2(stackbase));
  489.   ADD_BINDING(current_open_module,ARG_2(stackbase),ARG_1(stackbase),nil);
  490.  
  491.   /* Symbols can't be GC'd and modules are safe anyway!! */
  492.  
  493.   tmp =
  494.     EUCALL_2(Fn_cons,ARG_2(stackbase),current_open_module->exported_names);
  495.   current_open_module->exported_names = tmp;
  496.  
  497.   if (CREATE_INTERFACE) update_interface(name,entry_count,"unknown",code);
  498.   ++entry_count;
  499.  
  500.   return(ARG_0(stackbase));
  501. }
  502.  
  503.  
  504. /*
  505.  
  506.  * Environment functions...
  507.  
  508.  */
  509.  
  510. LispObject make_anonymous_module_env_function_1(LispObject *stacktop,
  511.                         LispObject mod,
  512.                         LispObject (*fun)(LispObject*),
  513.                         int argtype,
  514.                         LispObject sym,
  515.                         LispObject val)
  516. {
  517.   LispObject lfunc;
  518.   LispObject env;
  519.  
  520.   STACK_TMP(sym); STACK_TMP(val);
  521.   lfunc = allocate_module_function(stacktop,mod,nil,fun,argtype); /* GC Safe */
  522.   UNSTACK_TMP(val); UNSTACK_TMP(sym);
  523.   STACK_TMP(lfunc);
  524.   /* Rig the environment... */
  525.  
  526.   env = allocate_env(stacktop,sym,val,NULL);
  527.   UNSTACK_TMP(lfunc);
  528.   lfunc->C_FUNCTION.env = env;
  529.  
  530.   return(lfunc);
  531. }
  532.  
  533. LispObject make_anonymous_module_env_function_2(LispObject *stacktop,
  534.                         LispObject mod,
  535.                         LispObject (*fun)(LispObject*),
  536.                         int argtype,
  537.                         LispObject sym1,
  538.                         LispObject val1,
  539.                         LispObject sym2,
  540.                         LispObject val2)
  541. {
  542.   LispObject lfunc;
  543.   LispObject env;
  544.   STACK_TMP(sym2); STACK_TMP(val2);
  545.   STACK_TMP(sym1); STACK_TMP(val1);
  546.   lfunc = allocate_module_function(stacktop,mod,nil,fun,argtype); /* GC Safe */
  547.   
  548.   /* Rig the environment... */
  549.   UNSTACK_TMP(val1); UNSTACK_TMP(sym1); STACK_TMP(lfunc);
  550.   env = allocate_env(stacktop,sym1,val1,NULL);
  551.   UNSTACK_TMP(lfunc);
  552.   UNSTACK_TMP(val2); UNSTACK_TMP(sym2); STACK_TMP(lfunc);
  553.   env = allocate_env(stacktop,sym2,val2,env);
  554.   UNSTACK_TMP(lfunc);
  555.   lfunc->C_FUNCTION.env = env;
  556.  
  557.   return(lfunc);
  558. }
  559.  
  560.